home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / hyperbole / hversion.el < prev    next >
Encoding:
Text File  |  1995-08-29  |  8.1 KB  |  232 lines
  1. ;;!emacs
  2. ;;
  3. ;; LCD-ENTRY:    hyperbole|Bob Weiner|hyperbole@hub.ucsb.edu|Everyday Info Manager|29-Aug-95|3.19.07|ftp.cs.uiuc.edu:/pub/xemacs/infodock/
  4. ;;
  5. ;; FILE:         hversion.el
  6. ;; SUMMARY:      Hyperbole version, system and load path information.
  7. ;; USAGE:        GNU Emacs Lisp Library
  8. ;; KEYWORDS:     hypermedia
  9. ;;
  10. ;; AUTHOR:       Bob Weiner
  11. ;; ORG:          Brown U.
  12. ;;
  13. ;; ORIG-DATE:     1-Jan-94
  14. ;; LAST-MOD:     29-Aug-95 at 11:08:34 by Bob Weiner
  15. ;;
  16. ;; This file is part of Hyperbole.
  17. ;; Available for use and distribution under the same terms as GNU Emacs.
  18. ;;
  19. ;; Copyright (C) 1994-1995, Free Software Foundation, Inc.
  20. ;; Developed with support from Motorola Inc.
  21. ;;
  22. ;; DESCRIPTION:  
  23. ;; DESCRIP-END.
  24.  
  25. ;;; ************************************************************************
  26. ;;; Public variables
  27. ;;; ************************************************************************
  28.  
  29. (defconst hyperb:version "03.19.07" "Hyperbole revision number.")
  30.  
  31. ;;; Support button highlighting and flashing under XEmacs.
  32. ;;;
  33. (defvar hyperb:xemacs-p
  34.   (let ((case-fold-search t))
  35.     (if (string-match "XEmacs" emacs-version)
  36.     emacs-version))
  37.   "Version string under XEmacs (not Lucid Emacs) or nil")
  38.  
  39. ;;; Support button highlighting and flashing under obsolete Lucid Emacs.
  40. ;;;
  41. (defvar hyperb:lemacs-p
  42.   (let ((case-fold-search t))
  43.     (if (string-match "XEmacs\\|Lucid" emacs-version)
  44.     emacs-version))
  45.   "Version string under XEmacs or Lucid Emacs or nil")
  46.  
  47. ;;; Support mouse handling under GNU Emacs V19.
  48. ;;;
  49. (defvar hyperb:emacs19-p
  50.   (and (not hyperb:lemacs-p)
  51.        (string-match "^19\\." emacs-version)
  52.        emacs-version)
  53.   "Version string under GNU Emacs 19 or nil")
  54.  
  55. ;;; Support button highlighting and flashing under obsolete Epoch.
  56. ;;;
  57. (defvar hyperb:epoch-p
  58.   (if (and (boundp 'epoch::version)
  59.        (stringp epoch::version))
  60.       (if (string< epoch::version "Epoch 4") "V3" "V4"))
  61.   "Simplified version string under Epoch, e.g. \"V4\", or nil")
  62.  
  63. ;; Koutlines work only with specific versions of Emacs 19 and XEmacs.
  64. (defconst hyperb:kotl-p
  65.   (if hyperb:lemacs-p
  66.       ;; Only works for XEmacs 19.9 and above.
  67.       (string-match "^19\\.9 \\|^19\\.[1-9][0-9]" emacs-version)
  68.     hyperb:emacs19-p)
  69.   "Non-nil iff this Emacs version supports the Hyperbole outliner.")
  70.  
  71. (defun sm-window-sys-term ()
  72.   "Returns the first part of the term-type if running under a window system, else nil.
  73. Where a part in the term-type is delimited by a '-' or  an '_'."
  74.   (let ((term (cond ((memq window-system '(x ns dps pm))
  75.              ;; X11, NEXTSTEP (DPS), or OS/2 Presentation Manager (PM)
  76.              (cond (hyperb:emacs19-p "emacs19")
  77.                (hyperb:lemacs-p  "lemacs")
  78.                (hyperb:epoch-p   "epoch")
  79.                (t                "xterm")))
  80.             ((or (featurep 'eterm-fns)
  81.              (equal (getenv "TERM") "NeXT")
  82.              (equal (getenv "TERM") "eterm"))
  83.              ;; NEXTSTEP add-on support to Emacs
  84.              "next")
  85.             ((or window-system 
  86.              (featurep 'sun-mouse) (featurep 'apollo))
  87.              (getenv "TERM")))))
  88.     (and term
  89.      (substring term 0 (string-match "[-_]" term)))))
  90.  
  91. (defconst hyperb:window-system (sm-window-sys-term)
  92.   "String name for window system or term type under which Emacs was run.
  93. If nil, no window system or mouse support is available.")
  94.  
  95. ;;; ************************************************************************
  96. ;;; Public functions to dynamically compute Hyperbole directory.
  97. ;;; ************************************************************************
  98.  
  99. (defvar hyperb:automount-prefixes
  100.   (if (and (boundp 'automount-dir-prefix) (stringp automount-dir-prefix))
  101.       automount-dir-prefix
  102.     "^/tmp_mnt/"
  103.     "*Regexp to match any automounter prefix in a pathname."))
  104.  
  105. (defun hyperb:stack-frame (function-list &optional debug-flag)
  106.   "Return the nearest Emacs Lisp stack frame which called any function symbol from FUNCTION-LIST or nil if no match.
  107. If FUNCTION-LIST contains 'load, 'autoload or 'require, detect
  108. autoloads not visible within the Lisp level stack frames.
  109.  
  110. With optional DEBUG-FLAG non-nil, if no matching frame is found, return list
  111. of stack frames (from innermost to outermost)."
  112.   (let ((count 0)
  113.     (frame-list)
  114.     (load-flag (or (memq 'load function-list)
  115.                (memq 'autoload function-list)
  116.                (memq 'require function-list)))
  117.     fsymbol
  118.     fbody
  119.     frame)
  120.     (or (catch 'hyperb:stack-frame
  121.       (while (setq frame (backtrace-frame count))
  122.         (if debug-flag (setq frame-list (cons frame frame-list)))
  123.         (setq count (1+ count)
  124.           fsymbol (nth 1 frame))
  125.         (and (eq fsymbol 'command-execute)
  126.          (not (memq 'command-execute function-list))
  127.          ;; Use command being executed instead because it might not
  128.          ;; show up in the stack anywhere else, e.g. if it is an
  129.          ;; autoload under Emacs 19.
  130.          (setq fsymbol (nth 2 frame)))
  131.         (cond ((and load-flag (symbolp fsymbol)
  132.             (fboundp fsymbol)
  133.             (listp (setq fbody (symbol-function fsymbol)))
  134.             (eq (car fbody) 'autoload))
  135.            (setq frame (list (car frame) 'load
  136.                      (car (cdr fbody))
  137.                      nil noninteractive nil))
  138.            (throw 'hyperb:stack-frame frame))
  139.           ((memq fsymbol function-list)
  140.            (throw 'hyperb:stack-frame frame))))
  141.       nil)
  142.     (if debug-flag (nreverse frame-list)))))
  143.  
  144. (defun hyperb:path-being-loaded ()
  145.   "Return the full pathname used by the innermost `load' or 'require' call.
  146. Removes any matches for `hyperb:automount-prefixes' before returning
  147. the pathname."
  148.   (let* ((frame (hyperb:stack-frame '(load require)))
  149.      (function (nth 1 frame))
  150.      file nosuffix)
  151.     (cond ((eq function 'load)
  152.        (setq file (nth 2 frame)
  153.          nosuffix (nth 5 frame)))
  154.       ((eq function 'require)
  155.        (setq file (or (nth 3 frame) (symbol-name (nth 2 frame))))))
  156.     (if (stringp file)
  157.     (setq nosuffix (or nosuffix
  158.                (string-match
  159.                 "\\.\\(elc?\\|elc?\\.gz\\|elc?\\.Z\\)$"
  160.                 file))
  161.           file (substitute-in-file-name file)
  162.           file (locate-file file load-path
  163.                 (if nosuffix "" ".elc:.el:.el.gz:.el.Z:")
  164.                 ;; accept any existing file
  165.                 0)
  166.           file (if (and (stringp file)
  167.                 (string-match hyperb:automount-prefixes file))
  168.                (substring file (1- (match-end 0)))
  169.              file)))))
  170.  
  171. (if (fboundp 'locate-file)
  172.     nil
  173.   (defun locate-file (file dir-list &optional suffix-string unused)
  174.     "Search for FILE in DIR-LIST.
  175. If optional SUFFIX-STRING is provided, allow file to be followed by one of the
  176. colon separated suffixes."
  177.     (let ((suffix-list))
  178.       (cond ((null suffix-string) (setq suffix-list '("")))
  179.         ((stringp suffix-string)
  180.          (let ((start 0)
  181.            (len  (length suffix-string)))
  182.            (while (and (< start len)
  183.                (string-match "[^:]+" suffix-string start))
  184.          (setq suffix-list
  185.                (cons (substring suffix-string
  186.                     (match-beginning 0)
  187.                     (match-end 0))
  188.                  suffix-list)
  189.                start (1+ (match-end 0))))
  190.            (setq suffix-list (nconc (nreverse suffix-list) '("")))))
  191.         (t (error "(locate-file): Invalid third arg, '%s', use a colon separated string of file suffixes"
  192.               suffix-string)))
  193.       (if (and (file-name-absolute-p file) (file-readable-p file))
  194.       file;; file exists without suffix addition, so return it
  195.     (if (file-name-absolute-p file) (setq dir-list '(nil)))
  196.     (if (equal file "") (error "(locate-file): Empty file argument"))
  197.     (let (suffixes pathname)
  198.       ;; Search dir-list for a matching, readable file.
  199.       (catch 'found
  200.         (while dir-list
  201.           (setq suffixes suffix-list)
  202.           (while suffixes
  203.         (setq pathname (expand-file-name
  204.                 (concat file (car suffixes))
  205.                 (car dir-list)))
  206.         (if (file-readable-p pathname)
  207.             (throw 'found pathname))
  208.         (setq suffixes (cdr suffixes)))
  209.           (setq dir-list (cdr dir-list)))))))))
  210.  
  211. ;;; ************************************************************************
  212. ;;; Public functions used by pulldown and popup menus
  213. ;;; ************************************************************************
  214.  
  215. (if (not (fboundp 'id-browse-file))
  216.     (fset 'id-browse-file 'find-file-read-only))
  217.  
  218. (if (not (fboundp 'id-info))
  219.     (defun id-info (node)
  220.       (if (br-in-browser) (br-to-view-window))
  221.       (Info-goto-node node)))
  222.  
  223. (if (not (fboundp 'id-tool-quit)) (fset 'id-tool-quit 'eval))
  224.  
  225. (if (not (fboundp 'id-tool-invoke))
  226.     (defun id-tool-invoke (sexp)
  227.       (if (commandp sexp)
  228.       (call-interactively sexp)
  229.     (funcall sexp))))
  230.  
  231. (provide 'hversion)
  232.